COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(DECLARE (SETQ NO-DISK-HACKS T))
C00015 ENDMK
C⊗;
(DECLARE (SETQ NO-DISK-HACKS T))
(DECLARE (REQUIRE UTIL 1 DSK (AID RPG)))
(DECLARE (READ))
(REQUIRE UTIL 1 DSK (AID RPG))
(DEFPROP LC0FNS
 (LC0FNS COMPL
	 COMP
	 PRUP
	 MKPUSH
	 COMPEXP
	 COMPLIS
	 LOADAC
	 COMCOND
	 COMBOOL
	 COMPANDOR)
VALUE)

;COMPL is the user-callable driver.  It is a FEXPR.  It takes as
;   an argument a single file name, e.g (COMPL FOO BAR DSK (FOO BAR))
;   EXPRs on a file called FILNAM will be compiled into LAP and
;   written on the file FILNAM.LAP. Other types of function 
;   definitions and non-definitions are simply copied to output.

(DEFUN FEXPR COMPL(FILE)
	(UWRITE)						;Open a file for output
	(APPLY 'EREAD FILE)					;Open input file
       	(SELECT-DISK-INPUT 
	 (READ-UNTIL-EOF WITH Z DO				;Read each expression in file
	(COND ((OR (EQ (CAR Z) (QUOTE DEFUN))
		   (AND	(EQ (CAR Z) (QUOTE DEFPROP))
			(EQ (CADDDR Z) (QUOTE EXPR))))
	       (PROG (PROG)
		     (SETQ PROG
			   (COND ((EQ (CAR Z) (QUOTE DEFUN))
				  (COMP	(CADR Z)
					(CADDR Z)
					(CADDDR Z)))
				 (T
				  (COMP	(CADR Z)
					(CADR (CADDR Z))
					(CADDR (CADDR Z))))))
		     ;;; Print out code in file
		     (UNSELECT-TTY (SELECT-DISK-OUTPUT (MAPC (FUNCTION PRINT) PROG)))
		     (PRINT (LIST (CADR Z) (LENGTH PROG)))))
	      (T (UNSELECT-TTY (SELECT-DISK-OUTPUT (PRINT Z))))))
       	(APPLY 'UFILE (LIST (CAR FILE) 'LAP))	;Close and rename file
	(QUOTE ENDCOMP)))

;COMP compiles a single function definition, returning a list of
;   the LAP code corresponding to the definition.  
;   FN is the atomic name of the function being compiled.
;   VARS is the formal parameter list for the function.
;   EXP is the function body.

(DEFUN COMP(FN VARS EXP)
  ((LAMBDA(N)
    (APPEND (LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
	    (MKPUSH N 1)
	    (COMPEXP EXP (MINUS N) (PRUP VARS 1))
	    (LIST
	     ;;; Maclisp change from (sub p (e n 0 n 0)) to (sub p (% 0 0 n n))
	     (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))
	    (QUOTE ((POPJ P) NIL))))
   (LENGTH VARS)))

;PRUP returns an A-LIST formed by pairing successive elements of
;   VARS with consecutive integers beginning with N.

(DEFUN PRUP(VARS N)
  (COND	((NULL VARS) NIL)
	(T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (ADD1 N))))))

;MKPUSH returns a list of N (PUSH P i) instructions, where i runs
;   from M to M+N-1.  Used to push arguments onto the stack.

(DEFUN MKPUSH(N M)
  (COND	((LESSP N M) NIL)
	(T
	 (CONS (LIST (QUOTE PUSH) (QUOTE P) M)
	       (MKPUSH N (ADD1 M))))))

;COMPEXP is the heart of LCOM0.  It determines precisely
;   what an expression is, and compiles appropriate code
;   for it.  It returns a list of that code.
;   EXP is the expression to be compiled.
;   M is minus the number of entries on the stack. When
;      added to a value retrieved from the A-LIST VPR, it
;      can be used to locate a variable on the stack.
;   VPR is an A-LIST, associating variable names with 
;      numbers which, when added to M, give stack offsets.
;   Both M and VPR maintain these definitions throughout.

(DEFUN COMPEXP(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))          ;NIL

	((EQ EXP T) (QUOTE ((MOVEI 1 (QUOTE T)))))  ;T


	;;; This wasn't here in 1.6 lcom0
	((NUMBERP EXP)                              ;number
	 (LIST
	  (LIST	(QUOTE MOVEI)
		1
		(LIST 'QUOTE EXP))))

	((ATOM EXP)                                 ;variable
	 (LIST
	  (LIST	(QUOTE MOVE)
		1
		(PLUS M (CDR (ASSOC EXP VPR)))
		(QUOTE P))))

	((OR (EQ (CAR EXP) (QUOTE AND))             ;boolean expression
	     (EQ (CAR EXP) (QUOTE OR))
	     (EQ (CAR EXP) (QUOTE NOT)))
	 ((LAMBDA(L1 L2)
	   (APPEND
	    (COMBOOL EXP M L1 NIL VPR)
	    (LIST (QUOTE (MOVEI 1 (QUOTE T)))
		  (LIST (QUOTE JRST) 0 L2)
		  L1
		  (QUOTE (MOVEI 1 0))
		  L2)))
	  (GENSYM)
	  (GENSYM)))

	((EQ (CAR EXP) (QUOTE COND))               ;COND
	 (COMCOND (CDR EXP) M (GENSYM) VPR))

	((EQ (CAR EXP) (QUOTE QUOTE))              ;QUOTE
	 (LIST (LIST (QUOTE MOVEI) 1 EXP)))

	((ATOM (CAR EXP))                          ;function call
	 ((LAMBDA(N)
	   (APPEND
	    (COMPLIS (CDR EXP) M VPR)
	    (LOADAC (DIFFERENCE 1 N) 1)
	    (LIST
	     (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))
	    (LIST
	     (LIST (QUOTE CALL)
		   N
		   ;;; Change from (call n (e foo) s) to (call n 'foo)
		   (LIST 'QUOTE (CAR EXP))
		   ))))
	  (LENGTH (CDR EXP))))

	((EQ (CAAR EXP) (QUOTE LAMBDA))           ;LAMBDA expression
	 ((LAMBDA(N)
	   (APPEND
	    (COMPLIS (CDR EXP) M VPR)
	    (COMPEXP
	     (CADDAR EXP)
	     (DIFFERENCE M N)
	     (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR))
	    (LIST
	     (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))))
	  (LENGTH (CDR EXP))))

	(T NIL)))                                 ;oops

;COMPLIS compiles code to evaluate each expression in a list of
;   expressions and to push those values onto the stack.  It
;   returns a list of that code.  It is used to compile code
;   to evaluate arguments to called functions or LAMBDA expressions.
;   U is a list of expressions.

(DEFUN COMPLIS (U M VPR)
  (COND	((NULL U) NIL)
	(T
	 (APPEND (COMPEXP (CAR U) M VPR)
		 (QUOTE ((PUSH P 1)))
		 (COMPLIS (CDR U) (SUB1 M) VPR)))))

;LOADAC returns a list of (MOVE i j P) instructions, loading
;   consecutive accumulators from the top of the stack.
;   K indexes the accumulator loaded.
;   N indexes the stack offset.

(DEFUN LOADAC (N K)
  (COND	((GREATERP N 0) NIL)
	(T
	 (CONS (LIST (QUOTE MOVE) K N (QUOTE P))
	       (LOADAC (ADD1 N) (ADD1 K))))))

;COMCOND compiles a COND.  
;   U is a list of clauses in the COND.
;   L is a label to be emitted at the end of all code for
;      the COND.

(DEFUN COMCOND(U M L VPR)
  (COND	((NULL U) (LIST L))
	(T
	 ((LAMBDA(L1)
	   (APPEND (COMBOOL (CAAR U) M L1 NIL VPR)
		   (COMPEXP (CADAR U) M VPR)
		   (LIST (LIST (QUOTE JRST) 0 L) L1)
		   (COMCOND (CDR U) M L VPR)))
	  (GENSYM)))))

;COMBOOL compiles code for a single predicate.  That is, the
;   code generated evaluates the predicate and branches somewhere,
;   depending on the value.
;   P is the predicate.
;   L is a label which represents the branch point.
;   FLG is a flag.  If FLG is NIL, code is to fall thru on non-NIL
;      result and branch to L on NIL result.  If FLG is non-NIL,
;      code is to fall thru on NIL result and branch to L on
;      non-NIL result.

(DEFUN COMBOOL(P M L FLG VPR)
  (COND	((ATOM P)                                        ;simple variable
	 (APPEND
	  (COMPEXP P M VPR)
	  (LIST
	   (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))

	((EQ (CAR P) (QUOTE AND))                        ;conjunction
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
	       (T
		((LAMBDA(L1)
		  (APPEND (COMPANDOR (CDR P) M L1 NIL VPR)
			  (LIST (LIST (QUOTE JRST) 0 L))
			  (LIST L1)))
		 (GENSYM)))))

	((EQ (CAR P) (QUOTE OR))                         ;disjunction
	 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
	       (T
		((LAMBDA(L1)
		  (APPEND (COMPANDOR (CDR P) M L1 T VPR)
			  (LIST (LIST (QUOTE JRST) 0 L))
			  (LIST L1)))
		 (GENSYM)))))

	((EQ (CAR P) (QUOTE NOT))                        ;negation
	 (COMBOOL (CADR P) M L (NOT FLG) VPR))

	(T                                               ;other expression
	 (APPEND
	  (COMPEXP P M VPR)
	  (LIST
	   (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
		 1
		 L))))))

;COMPANDOR compiles code for lists of predicates connected 
;   conjunctively or disjunctively.
;   U is a list of predicates.
;   L is a label.
;   FLG is a flag.  If FLG is NIL, we are to fall thru on non-NIL
;      results and branch to L on NIL results (AND case).  If FLG
;      is non-NIL, we are to fall thru on NIL results and branch
;      to L on non-NIL results (OR case).

(DEFUN COMPANDOR(U M L FLG VPR)
  (COND	((NULL U) NIL)
	(T
	 (APPEND (COMBOOL (CAR U) M L FLG VPR)
		 (COMPANDOR (CDR U) M L FLG VPR)))))